home *** CD-ROM | disk | FTP | other *** search
/ AmigActive 2 / AACD 2.iso / AACD / Programming / fpc / compiler / win_targ.pas < prev   
Pascal/Delphi Source File  |  1998-09-24  |  7KB  |  207 lines
  1. {
  2.     $Id: win_targ.pas,v 1.1.1.1 1998/03/25 11:18:15 root Exp $
  3.     Copyright (c) 1998 by Florian Klaempfl
  4.  
  5.     This unit implements some support routines for the win32 target like
  6.     import/export handling
  7.  
  8.     This program is free software; you can redistribute it and/or modify
  9.     it under the terms of the GNU General Public License as published by
  10.     the Free Software Foundation; either version 2 of the License, or
  11.     (at your option) any later version.
  12.  
  13.     This program is distributed in the hope that it will be useful,
  14.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  15.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16.     GNU General Public License for more details.
  17.  
  18.     You should have received a copy of the GNU General Public License
  19.     along with this program; if not, write to the Free Software
  20.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22.  ****************************************************************************
  23. }
  24. unit win_targ;
  25.  
  26.   interface
  27.  
  28.   uses import;
  29.  
  30.   type
  31.     pimportlibwin32=^timportlibwin32;
  32.     timportlibwin32=object(timportlib)
  33.       procedure preparelib(const s:string);virtual;
  34.       procedure importprocedure(const func,module:string;index:longint;const name:string);virtual;
  35.       procedure generatelib;virtual;
  36.     end;
  37.  
  38.   implementation
  39.  
  40.     uses
  41.        aasm,files,strings,globals,cobjects
  42. {$ifdef i386}
  43.        ,i386
  44. {$endif}
  45. {$ifdef m68k}
  46.        ,m68k
  47. {$endif}
  48.        ;
  49.  
  50.     procedure timportlibwin32.preparelib(const s : string);
  51.  
  52.       begin
  53.          if not(assigned(importssection)) then
  54.            importssection:=new(paasmoutput,init);
  55.       end;
  56.  
  57.     procedure timportlibwin32.importprocedure(const func,module : string;index : longint;const name : string);
  58.  
  59.       var
  60.          hp1 : pimportlist;
  61.          hp2 : pimported_procedure;
  62.  
  63.       begin
  64.          { search for the module }
  65.          hp1:=pimportlist(current_module^.imports^.first);
  66.          while assigned(hp1) do
  67.            begin
  68.               if module=hp1^.dllname^ then
  69.                 break;
  70.               hp1:=pimportlist(hp1^.next);
  71.            end;
  72.          { generate a new item ? }
  73.          if not(assigned(hp1)) then
  74.            begin
  75.               hp1:=new(pimportlist,init(module));
  76.               current_module^.imports^.concat(hp1);
  77.            end;
  78.          hp2:=new(pimported_procedure,init(func,name,index));
  79.          hp1^.imported_procedures^.concat(hp2);
  80.       end;
  81.  
  82.     procedure timportlibwin32.generatelib;
  83.  
  84.       var
  85.          hp1 : pimportlist;
  86.          hp2 : pimported_procedure;
  87.          l1,l2,l3,l4 : plabel;
  88.          r : preference;
  89.  
  90.       begin
  91.          hp1:=pimportlist(current_module^.imports^.first);
  92.          while assigned(hp1) do
  93.            begin
  94.               getlabel(l1);
  95.               getlabel(l2);
  96.               getlabel(l3);
  97.               { create import directory entry }
  98.               importssection^.concat(new(pai_section,init('.idata$2')));
  99.               { pointer to procedure names }
  100.               importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
  101.                 (l2)))));
  102.               { two empty entries follow }
  103.               importssection^.concat(new(pai_const,init_32bit(0)));
  104.               importssection^.concat(new(pai_const,init_32bit(0)));
  105.               { pointer to dll name }
  106.               importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
  107.                 (l1)))));
  108.               { pointer to fixups }
  109.               importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
  110.                 (l3)))));
  111.  
  112.               { now walk through all imported procedures }
  113.               { we could that do in one while loop, but  }
  114.               { this would give too much idata* entries  }
  115.  
  116.               { first write the name references }
  117.               importssection^.concat(new(pai_section,init('.idata$4')));
  118.               importssection^.concat(new(pai_label,init(l2)));
  119.               hp2:=pimported_procedure(hp1^.imported_procedures^.first);
  120.               while assigned(hp2) do
  121.                 begin
  122.                    getlabel(plabel(hp2^.lab));
  123.                    importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
  124.                      (hp2^.lab)))));
  125.                    hp2:=pimported_procedure(hp2^.next);
  126.                 end;
  127.               { finalize the names ... }
  128.               importssection^.concat(new(pai_const,init_32bit(0)));
  129.  
  130.               { then the addresses and create also the indirect jump }
  131.               importssection^.concat(new(pai_section,init('.idata$5')));
  132.               importssection^.concat(new(pai_label,init(l3)));
  133.               hp2:=pimported_procedure(hp1^.imported_procedures^.first);
  134.               while assigned(hp2) do
  135.                 begin
  136.                    getlabel(l4);
  137.                    { text segment should be aligned }
  138.                    codesegment^.concat(new(pai_align,init_op(4,$90)));
  139.                    codesegment^.concat(new(pai_symbol,init_global(hp2^.func^)));
  140.                    { the indirect jump }
  141.                    new(r);
  142.                    reset_reference(r^);
  143.                    r^.symbol:=stringdup(lab2str(l4));
  144. {$ifdef i386}
  145.                    codesegment^.concat(new(pai386,op_ref(A_JMP,S_NO,r)));
  146. {$endif}
  147.                    importssection^.concat(new(pai_label,init(l4)));
  148.                    importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
  149.                       (hp2^.lab)))));
  150.                    hp2:=pimported_procedure(hp2^.next);
  151.                 end;
  152.               { finalize the addresses }
  153.               importssection^.concat(new(pai_const,init_32bit(0)));
  154.  
  155.               { finally the import information }
  156.               importssection^.concat(new(pai_section,init('.idata$6')));
  157.               hp2:=pimported_procedure(hp1^.imported_procedures^.first);
  158.               while assigned(hp2) do
  159.                 begin
  160.                    importssection^.concat(new(pai_label,init(hp2^.lab)));
  161.                    { the ordinal number }
  162.                    importssection^.concat(new(pai_const,init_16bit(hp2^.ordnr)));
  163.                    importssection^.concat(new(pai_string,init(hp2^.name^+#0)));
  164.                    hp2:=pimported_procedure(hp2^.next);
  165.                 end;
  166.               { create import dll name }
  167.               importssection^.concat(new(pai_section,init('.idata$7')));
  168.               importssection^.concat(new(pai_label,init(l1)));
  169.               importssection^.concat(new(pai_string,init(hp1^.dllname^+#0)));
  170.  
  171.               hp1:=pimportlist(hp1^.next);
  172.            end;
  173.       end;
  174.  
  175. end.
  176. {
  177.   $Log: win_targ.pas,v $
  178.   Revision 1.1.1.1  1998/03/25 11:18:15  root
  179.   * Restored version
  180.  
  181.   Revision 1.9  1998/03/10 13:23:00  florian
  182.     * small win32 problems fixed
  183.  
  184.   Revision 1.8  1998/03/10 01:17:31  peter
  185.     * all files have the same header
  186.     * messages are fully implemented, EXTDEBUG uses Comment()
  187.     + AG... files for the Assembler generation
  188.  
  189.   Revision 1.7  1998/03/04 10:35:34  florian
  190.     * writing of externals fixed
  191.  
  192.   Revision 1.6  1998/03/02 13:38:52  peter
  193.     + importlib object
  194.     * doesn't crash on a systemunit anymore
  195.     * updated makefile and depend
  196.  
  197.   Revision 1.4  1998/02/28 14:43:50  florian
  198.     * final implemenation of win32 imports
  199.     * extended tai_align to allow 8 and 16 byte aligns
  200.  
  201.   Revision 1.3  1998/02/28 09:30:59  florian
  202.     + writing of win32 import section added
  203.  
  204.   Revision 1.2  1998/02/28 00:20:35  florian
  205.     * more changes to get import libs for Win32 working
  206. }
  207.